home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / bristol.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  7.7 KB  |  287 lines

  1. ; AisleRiot - bristol.scm
  2. ; Copyright (C) 1999, 2003 Rosanna Yuen <rwsy@mit.edu>
  3. ;
  4. ; This game is free software; you can redistribute it and/or modify
  5. ; it under the terms of the GNU General Public License as published by
  6. ; the Free Software Foundation; either version 2, or (at your option)
  7. ; any later version.
  8. ;
  9. ; This program is distributed in the hope that it will be useful,
  10. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ; GNU General Public License for more details.
  13. ;
  14. ; You should have received a copy of the GNU General Public License
  15. ; along with this program; if not, write to the Free Software
  16. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  17. ; USA
  18.  
  19. (define (new-game)
  20.   (initialize-playing-area)
  21.   (set-ace-low)
  22.   (make-standard-deck)
  23.   (shuffle-deck)
  24.  
  25.   (add-normal-slot DECK)
  26.  
  27.   (set! HORIZPOS (+ HORIZPOS 0.75))
  28.  
  29.   (add-normal-slot '())
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.  
  33.   (set! HORIZPOS (+ HORIZPOS 0.75))
  34.   (add-normal-slot '())
  35.   (add-normal-slot '())
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.  
  39.   (add-carriage-return-slot)
  40.  
  41.   (add-extended-slot '() right)
  42.   (add-blank-slot)
  43.   (set! HORIZPOS (+ HORIZPOS 0.75))
  44.   (add-extended-slot '() right)
  45.   (add-blank-slot)
  46.   (set! HORIZPOS (+ HORIZPOS 0.75))
  47.   (add-extended-slot '() right)
  48.   (add-blank-slot)
  49.   (set! HORIZPOS (+ HORIZPOS 0.75))
  50.   (add-extended-slot '() right)
  51.  
  52.   (add-carriage-return-slot)
  53.  
  54.   (add-extended-slot '() right)
  55.   (add-blank-slot)
  56.   (set! HORIZPOS (+ HORIZPOS 0.75))
  57.   (add-extended-slot '() right)
  58.   (add-blank-slot)
  59.   (set! HORIZPOS (+ HORIZPOS 0.75))
  60.   (add-extended-slot '() right)
  61.   (add-blank-slot)
  62.   (set! HORIZPOS (+ HORIZPOS 0.75))
  63.   (add-extended-slot '() right)
  64.  
  65.   (deal-cards-face-up 0 '(8 9 10 11 12 13 14 15 
  66.                 8 9 10 11 12 13 14 15 
  67.                 8 9 10 11 12 13 14 15))
  68.   (check-for-kings 8)
  69.  
  70.   (give-status-message)
  71.  
  72.   (list 11 3))
  73.  
  74. (define (give-status-message)
  75.   (set-statusbar-message (get-stock-no-string)))
  76.  
  77. (define (get-stock-no-string)
  78.   (string-append (_"Stock left:") " "
  79.          (number->string (length (get-cards 0)))))
  80.  
  81. (define (check-for-kings slot-id)
  82.   (if (> slot-id 15)
  83.       #f
  84.       (begin
  85.     (if (= (get-value (get-top-card slot-id)) king)
  86.         (begin
  87.           (let ((new-deck (get-cards slot-id)))
  88.         (set-cards! slot-id (list (cadr new-deck)
  89.                       (caddr new-deck)
  90.                       (car new-deck))))
  91.           (if (= (get-value (get-top-card slot-id)) king)
  92.           (begin
  93.             (let ((new-deck (get-cards slot-id)))
  94.               (set-cards! slot-id (list (cadr new-deck)
  95.                         (caddr new-deck)
  96.                         (car new-deck)))))))
  97.         (if (= (get-value (cadr (get-cards slot-id))) king)
  98.         (let ((new-deck (get-cards slot-id)))
  99.           (set-cards! slot-id (list (car new-deck)
  100.                         (caddr new-deck)
  101.                         (cadr new-deck))))))
  102.     (check-for-kings (+ 1 slot-id)))))
  103.  
  104. (define (button-pressed slot-id card-list)
  105.   (and (not (empty-slot? slot-id))
  106.        (not (= slot-id 0))
  107.        (not (and (> slot-id 3)
  108.          (< slot-id 8)))
  109.        (= (length card-list) 1)))
  110.  
  111. (define (droppable? start-slot card-list end-slot)
  112.   (cond ((= start-slot end-slot) #f)
  113.     ((and (> end-slot 3)
  114.           (< end-slot 8))
  115.      (cond ((empty-slot? end-slot)
  116.         (= (get-value (car card-list)) ace))
  117.            (#t
  118.             (= (+ 1 (get-value (get-top-card end-slot)))
  119.            (get-value (car card-list))))))
  120.     (#t (and (> end-slot 7)
  121.           (not (empty-slot? end-slot))
  122.           (= (get-value (get-top-card end-slot))
  123.          (+ 1 (get-value (car card-list))))))))
  124.  
  125. (define (button-released start-slot card-list end-slot)
  126.   (and (droppable? start-slot card-list end-slot)
  127.        (or (< end-slot 4)
  128.        (> end-slot 7)
  129.        (add-to-score! 1))
  130.        (move-n-cards! start-slot end-slot card-list)))
  131.  
  132. (define (button-clicked slot-id)
  133.   (if (and (= slot-id 0)
  134.        (not (empty-slot? 0)))
  135.       (if (> (length (get-cards slot-id)) 3)
  136.       (deal-cards-face-up 0 '(1 2 3))
  137.       (deal-cards-face-up 0 '(1)))
  138.       #f))
  139.  
  140. (define (move-to-foundations? slot-id f-slot)
  141.   (cond ((= f-slot 8)
  142.      #f)
  143.     ((and (not (empty-slot? f-slot))
  144.           (= (get-value (get-top-card slot-id))
  145.          (+ 1 (get-value (get-top-card f-slot)))))
  146.      (begin
  147.        (add-to-score! 1)
  148.        (deal-cards slot-id (list f-slot))))
  149.     (#t
  150.      (move-to-foundations? slot-id (+ 1 f-slot)))))
  151.  
  152. (define (button-double-clicked slot-id)
  153.   (if (and (> slot-id 0)
  154.        (or (< slot-id 4)
  155.            (> slot-id 7))
  156.        (not (empty-slot? slot-id)))
  157.       (if (= ace  (get-value (get-top-card slot-id)))
  158.       (begin
  159.         (add-to-score! 1)
  160.         (cond ((empty-slot? 4)
  161.            (deal-cards slot-id '(4)))
  162.           ((empty-slot? 5)
  163.            (deal-cards slot-id '(5)))
  164.           ((empty-slot? 6)
  165.            (deal-cards slot-id '(6)))
  166.           (#t
  167.            (deal-cards slot-id '(7)))))
  168.       (move-to-foundations? slot-id 4))
  169.       #f))
  170.  
  171. (define (game-continuable)
  172.   (give-status-message)
  173.   (and (not (game-won))
  174.        (get-hint)))
  175.  
  176. (define (game-won)
  177.   (and (= 13 (length (get-cards 4)))
  178.        (= 13 (length (get-cards 5)))
  179.        (= 13 (length (get-cards 6)))
  180.        (= 13 (length (get-cards 7)))))
  181.  
  182. (define (check-a-foundation slot-id foundation-id)
  183.   (if (or (> foundation-id 7)
  184.       (empty-slot? slot-id))
  185.       #f
  186.       (cond ((and (empty-slot? foundation-id)
  187.           (= (get-value (get-top-card slot-id)) ace))
  188.          (list 2
  189.            (get-name (get-top-card slot-id)) 
  190.            (_"an empty foundation pile")))
  191.         ((and (not (empty-slot? foundation-id))
  192.           (= (+ 1 (get-value (get-top-card foundation-id)))
  193.              (get-value (get-top-card slot-id))))
  194.          (list 1
  195.            (get-name (get-top-card slot-id))
  196.            (get-name (get-top-card foundation-id))))
  197.         (#t (check-a-foundation slot-id (+ 1 foundation-id))))))
  198.  
  199. (define (check-to-foundations slot-id)
  200.   (cond ((> slot-id 15)
  201.      #f)
  202.     ((= slot-id 4)
  203.      (check-to-foundations 8))
  204.     ((check-a-foundation slot-id 4)
  205.      (check-a-foundation slot-id 4))
  206.     (#t
  207.      (check-to-foundations (+ 1 slot-id)))))
  208.  
  209. (define (check-reserve slot-id)
  210.   (if (> slot-id 3)
  211.       #f
  212.       (or (and (not (empty-slot? slot-id))
  213.            (check-a-tslot slot-id 
  214.                   (get-cards slot-id)
  215.                   1
  216.                   8))
  217.       (check-reserve (+ 1 slot-id)))))
  218.  
  219. (define (deepness card-list temp-deepness)
  220.   (if (and (> (length card-list) 1)
  221.        (= (+ 1 (get-value (car card-list)))
  222.           (get-value (cadr card-list))))
  223.       (deepness (cdr card-list) (+ 1 temp-deepness))
  224.       temp-deepness))
  225.  
  226. (define (check-a-tslot slot1 card-list depth slot2)
  227.   (if (or (> slot2 15)
  228.       (and (= (length card-list) depth)
  229.            (> slot1 7)))
  230.       #f
  231.       (if (and (not (empty-slot? slot2))
  232.            (not (= slot1 slot2))
  233.            (= (+ 1 (get-value (car card-list)))
  234.           (get-value (get-top-card slot2))))
  235.       (if (= depth 1)
  236.           (list 1 
  237.             (get-name (get-top-card slot1))
  238.             (get-name (get-top-card slot2)))
  239.  
  240.           (and (check-a-tslot slot1 
  241.                   (cdr card-list)
  242.                   (- depth 1)
  243.                   8)
  244.            (list 1 
  245.              (get-name (get-top-card slot1))
  246.              (get-name (get-top-card slot2)))))
  247.       (check-a-tslot slot1 card-list depth (+ 1 slot2)))))
  248.  
  249. (define (check-tableau slot-id)
  250.   (if (> slot-id 15)
  251.       #f
  252.       (if (and (not (empty-slot? slot-id))
  253.            (check-a-tslot slot-id 
  254.                   (get-cards slot-id) 
  255.                   (deepness (get-cards slot-id) 1) 
  256.                   8))
  257.       (check-a-tslot slot-id 
  258.                   (get-cards slot-id) 
  259.                   (deepness (get-cards slot-id) 1) 
  260.                   8)
  261.       (check-tableau (+ 1 slot-id)))))
  262.  
  263. (define (dealable?)
  264.   (and (not (empty-slot? 0))
  265.        (list 0 (_"Deal another round"))))
  266.  
  267. (define (get-hint)
  268.   (or (check-to-foundations 1)
  269.       (check-reserve 1)
  270.       (check-tableau 8)
  271.       (dealable?)))
  272.  
  273. (define (get-options) 
  274.   #f)
  275.  
  276. (define (apply-options options) 
  277.   #f)
  278.  
  279. (define (timeout) 
  280.   #f)
  281.  
  282. (set-features droppable-feature)
  283.  
  284. (set-lambda new-game button-pressed button-released button-clicked
  285. button-double-clicked game-continuable game-won get-hint get-options
  286. apply-options timeout droppable?)
  287.